Solutions: Mathematica 6 Lab 6

Problem 1: River Meanders

α=(π/5);
a=Sin[α];
b=Cos[α];

x1[θ_]:=a+Cos[θ]
x2[θ_]:=3a+Cos[θ]
x3[θ_]:=5a+Cos[θ]
x4[θ_]:=7a+Cos[θ]
x5[θ_]:=9a+Cos[θ]
y[θ_]:=b+Sin[θ]
z[θ_]:=-b+Sin[θ]

upperloops=ParametricPlot[{{x1[θ],y[θ]},{x3[θ],y[θ]},{x5[θ],y[θ]}},{θ,-(π/2)+α,((3π)/2)-α},
AspectRatio->Automatic,
PlotStyle->{
{Blue,Thickness[0.02]},
{Blue,Thickness[0.02]},
{Blue,Thickness[0.02]}},Axes->False,PlotRange->{{-1,8},{-2,2}}]

lowerloops=ParametricPlot[{{x2[θ],z[θ]},{x4[θ],z[θ]}},{θ,-((3π)/2)+α,(π/2)-α},
AspectRatio->Automatic,
PlotStyle->{
{Blue,Thickness[0.02]},
{Blue,Thickness[0.02]}},Axes->False,PlotRange->{{-1,8},{-2,2}}]

Show[upperloops,lowerloops,Graphics[{Thickness[0.01],Red,Line[{{0,0},{10a,0}}]}]]

bluearc=ParametricPlot[{Cos[θ],Sin[θ]},{θ,α,π},AspectRatio->Automatic,
Ticks->False,Axes->False,PlotStyle->{Blue,
Thickness[0.02]}]

lines=Graphics[{Line[{{-1,0},{Cos[α],0}}],
Line[{{0,0},{Cos[α],Sin[α]}}],
{Red,Thickness[0.01],
Line[{{Cos[α],0},{Cos[α],Sin[α]}}]},Text[StyleForm["α",FontSize->14],{0.15,0.05}]}]

Show[bluearc,lines]

Clear[α]

Plot[π Sin[α]+α-π,{α,0,1}]

α/.FindRoot[π Sin[α]+α-π==0,{α,0.8}]

%(180/π)

α=0.827858
a=Sin[α]
b=Cos[α]

x1[θ_]:=a+Cos[θ]
x2[θ_]:=3a+Cos[θ]
x3[θ_]:=5a+Cos[θ]
x4[θ_]:=7a+Cos[θ]
x5[θ_]:=9a+Cos[θ]
y[θ_]:=b+Sin[θ]
z[θ_]:=-b+Sin[θ]

upperloops=ParametricPlot[{{x1[θ],y[θ]},{x3[θ],y[θ]},{x5[θ],y[θ]}},{θ,-(π/2)+α,((3π)/2)-α},
AspectRatio->Automatic,
PlotStyle->{
{Blue,Thickness[0.02]},
{Blue,Thickness[0.02]},
{Blue,Thickness[0.02]}},Axes->False,PlotRange->{{-1,8},{-2,2}}]

lowerloops=ParametricPlot[{{x2[θ],z[θ]},{x4[θ],z[θ]}},{θ,-((3π)/2)+α,(π/2)-α},
AspectRatio->Automatic,
PlotStyle->{
{Blue,Thickness[0.02]},
{Blue,Thickness[0.02]}},Axes->False,PlotRange->{{-1,8},{-2,2}}]

Show[upperloops,lowerloops]

Problem 2: Solitons

Clear[a,b]

?D

u[x_,t_,b_]:=(b^2)2 ((Sech[b  x-4(b^3) t])^2)

D[u[x,t,b],t]+6u[x,t,b]D[u[x,t,b],x]+ D[u[x,t,b],{x,3}]==0

Simplify[%]

Animate[Plot[{u[x,t,1],u[x,t,(1/(Sqrt[2]))]},{x,-4,20},PlotRange->{0,3}],{t,0,4},AnimationRunning->False]

Problem 3: Fourier Analysis of Gaussian & Soliton

Clear[a,b,g]

?FourierTransform
?InverseFourierTransform

g[x_,a_]:=(Sqrt[(a/(2π))])(E^(-(1/2)a (x^2)))

(∫_(-∞)^∞)g[x,a]\[DifferentialD]x

G[y_,a_]:=FourierTransform[g[x,a],x,y]

g[x,a]
G[y,a]

Manipulate[GraphicsGrid[{{Plot[Evaluate[g[x,a]],{x,-5,5},PlotStyle->{Red,Thick}, PlotRange->{0,1.0},AxesLabel->{x,"Gaussian"}]},{Plot[Evaluate[G[y,a]],{y,-5,5},PlotStyle->{Blue,Thick}, PlotRange->{0,1.0},AxesLabel->{y,"Its Fourier Transform"}]}}],{a,(1/5),5}]

g[x,a]==InverseFourierTransform[G[y,a],y,x]

h[x_,b_]:=(b/2)((Sech[b x])^2)

(∫_(-∞)^∞)h[x,b]\[DifferentialD]x

H[y_,b_]:=FourierTransform[(b/2)((Sech[b x])^2),x,y]

H[y,b]

Manipulate[GraphicsGrid[{{Plot[Evaluate[(b/2)((Sech[b x])^2)],{x,-5,5},PlotStyle->{Red,Thick}, PlotRange->{0,1.0},AxesLabel->{x,"SechSquared"}]},{Plot[Evaluate[(((Sqrt[(π/2)]) y Csch[((π y)/(2 b))])/(2 b))],{y,-5,5},PlotStyle->{Blue,Thick}, PlotRange->{0,1.0},AxesLabel->{y,"Its Fourier Transform"}]}}],{b,(1/2),2}]

h[x,b]==InverseFourierTransform[H[y,b],y,x]

Problem 4:  Gibbs' Phenomenon

Needs["FourierSeries`"]

?FourierSeries

squarewave[x_]:=-UnitStep[x+3]+2UnitStep[x+2]-2UnitStep[x+1]+2UnitStep[x]-2UnitStep[x-1]+2UnitStep[x-2]

Exact=Plot[squarewave[x],{x,-3,3},AspectRatio->Automatic, PlotStyle->{Red,Thick}]

FourierTrigSeries[squarewave[x],x,15,FourierParameters->{0,1/2}]

Expand[%]

f[x_,n_]:=(∑_(k=0)^n)((4Sin[(2k+1)π x])/((2k+1)π))

f[x,7]

Manipulate[Plot[f[x,n],{x,-3,3},AspectRatio->Automatic],{n,5,25,5}]

gibbs[x_,n_]:=1-f[x,n]
absolutegibbs[x_,n_]:=Abs[gibbs[x,n]]

Manipulate[Plot[absolutegibbs[x,n],{x,0,1},PlotRange->{0,1}],{n,5,25,1}]

Plot[Abs[gibbs[x,7]],{x,0,1},PlotRange->{0,1}]

Problem 5:  Griffiths' "Needle Problem"

gibbsprime[x_,n_]:=D[gibbs[x,n],x]

Clear[x]

NSolve[{gibbsprime[x,7]==0,Abs[x]==x},x]

peaks={x,Abs[gibbs[x,7]]}/.%

Plot[Abs[gibbs[x,7]],{x,0,1},PlotRange->{0,1},
Epilog->{PointSize[0.02],Red,Map[Point,peaks]}]

?Fit

Fit[peaks, {1,(1/(((x(1-x)))^(1/2)))},x]

GriffithsAndLi[x_]:=-0.0950098359453018`+((0.06587823453635137`)/(Sqrt[(1-x) x]))

Plot[GriffithsAndLi[x],{x,0,1},PlotRange->{0,1},
Epilog->{PointSize[0.02],Red,Map[Point,peaks]}]

Fit[peaks, {1,(1/(((x(1-x)))^(1/3)))},x]

Plot[-0.1893806001173922`+((0.14155126404863597`)/((((1-x) x))^(1/3))),{x,0,1},PlotRange->{0,1},
Epilog->{PointSize[0.02],Red,Map[Point,peaks]}]

Plot[{(((4x(1-x)))^(-(1/2))),(((4x(1-x)))^(-(1/4))),(((4x(1-x)))^(-(1/8)))},{x,0,1},PlotRange->{0,4},PlotStyle->{Red,Black,Blue}]

Problem 5:  Link Creation & Imported Graphic

Hyperlink["Narcissus","http://en.wikipedia.org/wiki/Narcissus_%28Caravaggio%29"]

Import["/Volumes/QUANTUM/Mathematica Labs 2007/Opened Solutions 2007 v.6/Caravaggio's Narcissus.rtfd/300px-Michelangelo_Caravaggio_065.jpg"]